home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / PROGS / UNITSCAN.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  12KB  |  390 lines
  1. PROGRAM UnitScan;
  2.  
  3. {$M 25000,0,655000}
  4.  
  5. Uses PbMISC, PbDATA, PbOBJS, PbPARMS, PbOUT0,
  6.      PbDBLIB, PbDBOBJ, xUnits, xProcs;
  7.  
  8. {
  9. Description : Scans .PAS for Procs & Functions
  10.  
  11. Author      : Howard Richoux
  12. Date        : 12/13/93
  13. Last revised: 5/2/94 HNR 1.20 creates dbf files as needed
  14. Application : IBM PC and compatibles, done in Turbo Pascal 7.0
  15. Status      : Placed in the Public Domain by HNR Software 1/29/1994
  16. Published in: none
  17. }
  18.  
  19.  
  20. type WorkProc_type = Procedure (var s : string);
  21.  
  22. type procrec = record
  23.        proclead : string[9];   { FUNCTION/PROCEDURE }
  24.        unitname : string[8];
  25.        procname : string[24];
  26.        procargs : string[254]; { ( var ... ) }
  27.        proctype : string[24];  { : string }
  28.        proccomm : string[254]; { comments }
  29.        end;
  30.  
  31.  
  32. var T   : TFILE_object;
  33. var UN  : UNITS_DBF_object;
  34. var PR  : PROCS_DBF_object;
  35. var P   : procrec;
  36. var QUITFlag : boolean;
  37.  
  38. var oktowrite  : boolean;
  39.     skipmode   : boolean;
  40.     state      : byte;
  41.     UnitString : string;
  42.     UsesString : string;
  43.  
  44. var procfname  : string;
  45.     unitfname  : string;
  46.  
  47. {*****************************************************************}
  48.  
  49. Function FmtP(P : procrec) : string;
  50. var s : string;
  51.      begin
  52.      s := P.procname;
  53.      if P.procargs <> '' then s := s + '(' + P.procargs + ')';
  54.      if P.proctype <> '' then s := s + ' : ' + P.proctype;
  55.      s := s + ';';
  56.      RemoveExcessBlanks(s);
  57.      FmtP := leftstr(P.proclead,9) + ' ' + s;
  58.      end;
  59.  
  60.  
  61. Procedure AddProcRecord(P : procrec);
  62.      begin
  63.      fillchar(PR.rec,sizeof(PR.rec),0);
  64.      PR.rec._UNITNAME  := P.unitname;
  65.      PR.rec._PROCNAME  := P.procname;
  66.      PR.rec._PROCLEAD  := P.proclead;
  67.      PR.rec._FUNCTYPE  := P.proctype;
  68.      PR.rec._STATEMENT := FmtP(p);
  69.      PR.rec._CATEGORY  := GetDelimitedStr(P.proccomm,'[',']');
  70.      PR.rec._COMMENT   := P.proccomm;
  71.      PR.rec._LASTMOD   := '0000000000';
  72.      PR.rec._AUTHOR    := 'hnr';
  73.      PR.rec._PROCSTATUS := 'ok';
  74.      PR.rec._CODESTATUS := 'ok';
  75.      if oktowrite then
  76.           begin
  77.           PR.writerec(PR.numrecs+1);
  78.         {  OUT('Wrote record '+P.procname); }
  79.           end;
  80.      end;
  81.  
  82.  
  83. Procedure DoneWithProc(var P : procrec; var s : string);
  84. var i : integer;
  85.     tch : char;
  86.     s1  : string;
  87.      begin
  88.      P.unitname := UnitString;
  89.  
  90.      OUT('['+leftstr(P.unitname,8)+'] '+FmtP(P));
  91.      trim(s);
  92.      i := pos('}',s);
  93.      if (i > 0 ) and (s[1]='{') then
  94.           begin
  95.           delete(s,1,1);
  96.           P.proccomm := GetLeftStr(s,'}');
  97.           OUT('                  {'+P.proccomm+'}');
  98.           trim(P.proccomm);
  99.           end;
  100.      AddProcRecord(P);
  101.      fillchar(P,sizeof(p),0);
  102.      state := 0;
  103.      end;
  104.  
  105.  
  106. Procedure FindProcs(var s : string; var done : boolean);
  107. var s1 : string;
  108.     ch, tch : char;
  109.     i  : integer;
  110.      begin
  111.      trim(s);
  112.      if leftstr(s,14) = 'IMPLEMENTATION' then
  113.           begin
  114.           done := true;
  115.           s := '';
  116.           writeln('*IMPLEMENTATION*');
  117.           end
  118.      else if (leftstr(s,3) = '{+}')  then
  119.           begin
  120.           delete(s,1,3);
  121.           skipmode := false;
  122.           if pDebug then
  123.                begin
  124.                OUT('{done skipping}');
  125.                OUT(' ');
  126.                end;
  127.           end
  128.      else if (leftstr(s,3) = '{-}') then
  129.           begin
  130.           delete(s,1,3);
  131.           skipmode := true;
  132.           if pDebug then
  133.                begin
  134.                OUT(' ');
  135.                OUT('{skipping}');
  136.                end;
  137.           end
  138.      else if leftstr(s,5) = 'USES ' then
  139.           begin
  140.           delete(s,1,5);
  141.           UsesString := NibbleString(s,[';'],tch);
  142.           OUT('USES '+ UsesString + ';');
  143.           OUT(' ');
  144.           end
  145.      else if leftstr(s,5) = 'UNIT ' then
  146.           begin
  147.           delete(s,1,5);
  148.           UnitString := NibbleString(s,[';'],tch);
  149.           OUT('UNIT '+ UnitString + ';');
  150.           OUT(' ');
  151.           end
  152.      else if not skipmode then
  153.           begin
  154.           if pDebug then OUT(integerstr(length(s),3)+'..'+leftstr(s,60));
  155.           case state of
  156.               0  : begin  {have nothing}
  157.                    s1 := NibbleString(s,[' '],tch);
  158.                    if (s1 = 'PROCEDURE') or
  159.                       (s1 = 'Procedure') or
  160.                       (s1 = 'procedure') or
  161.                       (s1 = 'function') or
  162.                       (s1 = 'Function') or
  163.                       (s1 = 'FUNCTION') then
  164.                          begin
  165.                          state := 1;
  166.                          P.proclead := trimstr(s1);
  167.                          if pDebug then
  168.                               OUT('[**'+integerstr(state,2)+'**] '+FmtP(P));
  169.                          end;
  170.                     trim(s);
  171.                     end;
  172.  
  173.               1  : begin  {have lead, look for name}
  174.                    s1 := NibbleString(s,[';',':','('],tch);
  175.                    P.procname := trimstr(s1);
  176.                    if tch = ';' then
  177.                         begin
  178.                         if pDebug then
  179.                            OUT('[**'+integerstr(state,2)+'**] '+FmtP(P));
  180.                         DoneWithProc(P,s);
  181.                         end
  182.                    else if tch = ':' then
  183.                         begin { no args, look for F type }
  184.                         state := 3;
  185.                         i := pos(')',s);
  186.                         if i > 0 then
  187.                              begin
  188.                              end;
  189.                         if pDebug then
  190.                             OUT('[**'+integerstr(state,2)+'**] '+FmtP(P));
  191.                         end
  192.                    else if tch = '(' then
  193.                         begin { args }
  194.                         state := 2;
  195.                         if pDebug then
  196.                            OUT('[**'+integerstr(state,2)+'**] '+FmtP(P));
  197.                         end
  198.                    end;
  199.  
  200.               2  : begin  {have open (, looking for )}
  201.                    i := pos(')',s);
  202.                    if i > 0 then
  203.                         begin
  204.                         P.procargs := trimstr(leftstr(s,i-1));
  205.                         delete(s,1,i);
  206.                         trim(s);
  207.                         if s[1] = ':' then
  208.                              begin
  209.                              state := 3;
  210.                              delete(s,1,1);
  211.                              trim(s);
  212.                              end
  213.                         else begin
  214.                              state := 4;
  215.                              end;
  216.                         if pDebug then
  217.                              OUT('[**'+integerstr(state,2)+'**] '+FmtP(P));
  218.                         end;
  219.                    end;
  220.  
  221.               3  : begin  {have :, looking for function type }
  222.                    P.proctype := GetLeftStr(s,';');
  223.                    DoneWithProc(P,s);
  224.                    if pDebug then
  225.                        OUT('[**'+integerstr(state,2)+'**] '+FmtP(P));
  226.                    trim(s);
  227.                    end;
  228.  
  229.               4  : begin  {need closing ; }
  230.                    s1 := GetLeftStr(s,';');
  231.                    DoneWithProc(P,s);
  232.                    trim(s);
  233.                    end;
  234.  
  235.               else begin { how did I get here? }
  236.                    writeln('Huh!' );
  237.                    writeln('[',s,']');
  238.                    done := true;
  239.                    s := '';
  240.                    end;
  241.               end;
  242.           end
  243.      else begin
  244.           if length(s) > 1 then delete(s,1,1);
  245.           end;
  246.      end;
  247.  
  248.  
  249.  
  250. Procedure  ReadLogicalBigChunk(fname : string);
  251. var s, ws : string;
  252.     ok,done : boolean;
  253.     badloop : longint;
  254.      begin
  255.      done := false;
  256.      badloop := 0;
  257.      s := ''; ws := ''; done := false; state := 0;
  258.      fillchar(P,sizeof(p),0);
  259.      T.init(fname,false);
  260.      while T.fetchnext(s) and not done do
  261.           begin
  262.           if length(ws) + length(s) < 250 then
  263.                begin
  264.                ws := ws + ' ' + s;
  265.                end
  266.           else begin
  267.                while length(ws) > 120 do FindProcs(ws,done);
  268.                ws := ws + ' ' + s;
  269.                end;
  270.           inc(badloop);
  271.           if badloop > 499999 then
  272.                begin
  273.                done := true;
  274.                writeln('BAD LOOP EXIT');
  275.                end;
  276.           end;
  277.      badloop := 0;
  278.      done := false;
  279.      while (length(ws) > 0) and not done  do
  280.           begin
  281.           inc(badloop);
  282.           if badloop > 50 then
  283.                begin
  284.                done := true;
  285.                end;
  286.           FindProcs(ws,done);
  287.           end;
  288.      T.done;
  289.      end;
  290.  
  291.  
  292. Procedure GoOn;
  293.      begin
  294.      if QUITFlag then exit;
  295.      OUT('File: '+pCurrFName);
  296.      OUT(' ');
  297.      ReadLogicalBigChunk(pCurrFName);
  298.      end;
  299.  
  300.  
  301. Procedure CreateUnitsFile;
  302. var spec : string;
  303.     err  : integer;
  304.      begin
  305.      spec := '[UNITNAME(C8),PATH(C30),PROCS(N3.0),FUNCTIONS(N3.0),OBJS(N3.0),'+
  306.              'UNITSTATUS(C4),CREATEDATE(D8),UNITUSES(C100),LASTMOD(D8),NOTES(C200),'+
  307.              'GLOBALS(C20)]';
  308.      if DBFCreateFile('units.dbf',spec,err) then
  309.           begin
  310.           UN.init(procfname,UNITS_DBF_recsize,fREADWRITE,'','',0);
  311.           if not UN.opened then
  312.                writeln('Unable to open or create UNITS.DBF');
  313.           end;
  314.      end;
  315.  
  316.  
  317. Procedure CreateProcsFile;
  318. var spec : string;
  319.     err  : integer;
  320.      begin
  321.      spec := '[UNITNAME(C8),PROCNAME(C20),PROCLEAD(C9),FUNCTYPE(C20),'+
  322.              'CATEGORY(C16),STATEMENT(C150),COMMENT(C100),LASTMOD(D8),'+
  323.              'AUTHOR(C8),PROCSTATUS(C4),CODESTATUS(C4)]';
  324.      if DBFCreateFile('procs.dbf',spec,err) then
  325.           begin
  326.           PR.init(procfname,PROCS_DBF_recsize,fREADWRITE,'','',0);
  327.           if not PR.opened then
  328.                writeln('Unable to open or create PROCS.DBF');
  329.           end;
  330.      end;
  331.  
  332.  
  333. Procedure OpendBaseFiles;
  334.      begin
  335.      procfname  := Addbackslash(pDataPath)+'procs.dbf';
  336.      OUT('using dbf files ['+procfname+']');
  337.      unitfname  := Addbackslash(pDataPath)+'units.dbf';
  338.      OUT('using dbf files ['+unitfname+']');
  339.  
  340.      PR.init(procfname,PROCS_DBF_recsize,fREADWRITE,'','',0);
  341.      if not PR.opened then CreateProcsFile;
  342.      if oktowrite then OUT('opened '+procfname+'  '+integerstr(PR.err,4));
  343.  
  344.      UN.init(unitfname,UNITS_DBF_recsize,fREADWRITE,'','',0);
  345.      if not UN.opened then CreateUnitsFile;
  346.      if oktowrite then OUT('opened '+unitfname+'  '+integerstr(UN.err,4));
  347.      end;
  348.  
  349.  
  350. Procedure Init;
  351.     begin
  352.     QUITFlag := false;
  353.    { CRT.checkBreak := true;}
  354.     UsesString := '<usestring>';
  355.     UnitString := '<unitstring>';
  356.     skipmode   := false;
  357.  
  358.     AddParm(1,'DBFWRITE','NO');
  359.  
  360.     StandardOUTInit;
  361.  
  362.     oktowrite := CheckOK('DBFWRITE');
  363.  
  364.     pProgID := 'UnitScan 1.05';
  365.     if not pDebug then OUTSetNoPause;
  366.  
  367.     OpendBaseFiles;
  368.     if oktowrite then
  369.          begin
  370.          OUT('Updating database on: ['+pDataPath+']');
  371.          if not PR.opened then QUITFlag := true;
  372.          end;
  373.     end;
  374.  
  375.  
  376. (*  Main program *)
  377.     BEGIN
  378.     pProgID := 'UNITSCAN 1.20';
  379.     Init;
  380.     if paramcount > 0 then
  381.          begin
  382.          pCurrFName := paramstr(1);
  383.          if fileexists(pCurrFName) then GoOn
  384.          else writeln('Unable to find file [',pCurrFName,']');
  385.          end;
  386.     OUTdone;
  387.     end.
  388.  
  389.  
  390.